home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / facilis.zip / FACILIS.PAS < prev    next >
Pascal/Delphi Source File  |  1985-03-05  |  23KB  |  865 lines
  1. { Facilis 0.20                                      file: FACILIS.PAS    }
  2. {$R+}
  3. program Facilis;
  4.  
  5.  { based on the Pascal S compiler of Niklaus Wirth,
  6.       as modified by R.E. Berry }
  7.  
  8.  { adapted for the IBMPC by John R. Naleszkiewicz }
  9.  
  10.  { extensions by Anthony M. Marcy }
  11.  
  12. const
  13.   version = 0.20;
  14.   nkw  =  35;     { no. of key words }
  15.   alng =  10;     { no. of significant chars in identifiers }
  16.   llng = 121;     { input line legnth }
  17.   emax =  38;     { max exponent of real numbers }
  18.   emin = -38;     { min exponent }
  19.   kmax =  11;     { max no. of significant digits }
  20.   tmax = 300;     { size of table }
  21.   bmax =  30;     { size of block-table }
  22.   amax =  30;     { size of array-table }
  23.   c2max=  50;     { size of real constant table }
  24.   csmax=  30;     { max no. of cases }
  25.   cmax =8000;     { size of code }
  26.   lmax =   7;     { maximum level }
  27.   ermax=  61;     { max error no. }
  28.   omax =  255;    { highest order code }
  29.   xmax =  32767;  { maximum array bound }
  30.   nmax =  32767;  { maximum integer }
  31.   lineleng  =   80; {output line length }
  32.   stacksize = 2000;
  33.  
  34. type
  35.   symbol =
  36.    (intcon,realcon,charcon,stringcon,
  37.     notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,insy,
  38.     eql,neq,gtr,geq,lss,leq,
  39.     lparent,rparent,lbrack,rbrack,comma,semicolon,period,twodots,
  40.     colon,becomes,constsy,typesy,varsy,funcsy,nilsy,
  41.     procsy,filesy,arraysy,recordsy,packedsy,setsy,programsy,labelsy,ident,
  42.     withsy,beginsy,ifsy,casesy,repeatsy,whilesy,forsy,gotosy,
  43.     endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);
  44.  
  45.   index  = -xmax..+xmax;
  46.   alfa   = packed array [1..alng] of char;
  47.   object = (konstant,vvariable,type1,prozedure,funktion);
  48.   types  = (notyp,ints,reals,bools,chars,strngs,arrays,records);
  49.   symset = set of symbol;
  50.   typset = set of types;
  51.   strng  = string[20];
  52.   order  = packed record
  53.              f: 0..omax;
  54.              x: 0..lmax;
  55.              y: -nmax..+nmax;
  56.            end ;
  57.  
  58. var
  59.   ch    : char;            { last character read from source program}
  60.   rnum  : real;            { real number from insymbol }
  61.   i,j   : integer;
  62.   inum  : integer;         { integer from insymbol }
  63.   sleng : integer;         { string length }
  64.   cc    : integer;         { character counter }
  65.   lc    : integer;         { program location counter }
  66.   ll    : integer;         { length of current line }
  67.   errpos: integer;
  68.   nul   : integer;         { seg of null string }
  69.   t,a,b,c1,c2: integer; { indices to tables}
  70.   skipflag, stackdump, prtables   : boolean;
  71.  
  72.   sy      : symbol;        { last symbol read by insymbol }
  73.   errs    : set of 0..ermax;
  74.   id      : alfa;          { identifier from insymbol }
  75.   progname: alfa;
  76.   stantyps: typset;
  77.   constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;
  78.  
  79.   line       : array [1..llng] of char;
  80.   key        : array [1..nkw] of alfa;
  81.   ksy        : array [1..nkw] of symbol;
  82.   sps        : array ['!'..'~'] of symbol;
  83.   display    : array [0 .. lmax] of integer;
  84.  
  85.   tab:     array [0 .. tmax] of     { identifier table }
  86.              record
  87.                name: alfa;        link: index;
  88.                obj : object;       typ: types;
  89.                ref : index;     normal: boolean;
  90.                lev : 0 .. lmax;    adr: integer
  91.              end ;
  92.  
  93.   atab:    array [1 .. amax] of     { array-table }
  94.              record
  95.                inxtyp, eltyp: types;
  96.                elref, low, high, elsize, size: index
  97.              end ;
  98.  
  99.   btab:    array [1 .. bmax] of     { block-table }
  100.              record
  101.                last, lastpar, psize, vsize: index
  102.              end ;
  103.  
  104.   spnt,tpnt: ^char;
  105.   rconst:  array [1 .. c2max] of real;
  106.  
  107.   code  :  array [0 .. cmax] of order;
  108.   opcode: byte;
  109.        x: byte;      { operand }
  110.        y: integer;   { operand }
  111.       pc: integer;   { program counter }
  112.  
  113.   psin, psout, prr, prd: text;
  114.   inf, outf, tempstr: strng;
  115.  
  116. procedure errormsg;
  117.  
  118. var    k: integer;
  119.      msg: array [0..ermax] of alfa;
  120.      begin
  121.        msg[ 0] := 'undef id  '; msg[ 1] :='multi def ';
  122.        msg[ 2] := 'identifier'; msg[ 3] :='program   ';
  123.        msg[ 4] := ')         '; msg[ 5] :=':         ';
  124.        msg[ 6] := 'syntax    '; msg[ 7] :='ident, var';
  125.        msg[ 8] := 'of        '; msg[ 9] :='(         ';
  126.        msg[10] := 'id, array '; msg[11] :='[         ';
  127.        msg[12] := ']         '; msg[13] :='..        ';
  128.        msg[14] := ';         '; msg[15] :='func. type';
  129.        msg[16] := '=         '; msg[17] :='boolean   ';
  130.        msg[18] := 'convar typ'; msg[19] :='type      ';
  131.        msg[20] := 'prog.param'; msg[21] :='too big   ';
  132.        msg[22] := '.         '; msg[23] :='typ (case)';
  133.        msg[24] := 'character '; msg[25] :='const id  ';
  134.        msg[26] := 'index type'; msg[27] :='indexbound';
  135.        msg[28] := 'no array  '; msg[29] :='type id   ';
  136.        msg[30] := 'undef type'; msg[31] :='no record ';
  137.        msg[32] := 'boole type'; msg[33] :='arith type';
  138.        msg[34] := 'integer   '; msg[35] :='types     ';
  139.        msg[36] := 'param type'; msg[37] :='variab id ';
  140.        msg[38] := 'string    '; msg[39] :='no.of pars';
  141.        msg[40] := 'real numbr'; msg[41] :='type      ';
  142.        msg[42] := 'real type '; msg[43] :='integer   ';
  143.        msg[44] := 'var, const'; msg[45] :='var, proc ';
  144.        msg[46] := 'types (:=)'; msg[47] :='typ (case)';
  145.        msg[48] := 'type      '; msg[49] :='store ovfl';
  146.        msg[50] := 'constant  '; msg[51] :=':=        ';
  147.        msg[52] := 'then      '; msg[53] :='until     ';
  148.        msg[54] := 'do        '; msg[55] :='to downto ';
  149.        msg[56] := 'begin     '; msg[57] :='end       ';
  150.        msg[58] := 'factor    '; msg[59] :='comma     ';
  151.        msg[60] := 'idx string'; msg[61] :='too big   ';
  152.  
  153.        writeln(psout); writeln(psout,' key words');
  154.        k:=0;
  155.        while errs <> [] do begin
  156.          while not (k in errs) do k := k+1;
  157.          writeln(psout,k,'  ',msg[k]);
  158.          errs := errs - [k]
  159.        end
  160.      end { errormsg } ;
  161.  
  162. procedure fatal(n: integer);
  163.  
  164. var    msg: array [1..8] of alfa;
  165. begin
  166.   writeln(psout); errormsg;
  167.  
  168.   msg[ 1] := 'identifier'; msg[ 2] := 'procedures';
  169.   msg[ 3] := 'reals     '; msg[ 4] := 'arrays    ';
  170.   msg[ 5] := 'levels    '; msg[ 6] := 'code      ';
  171.   msg[ 7] := 'strings   '; msg[ 8] := 'input line';
  172.  
  173.   writeln(psout,' compiler table for ', msg[n], ' is too small');
  174.   close(psout); halt       {terminate compilation}
  175. end { fatal } ;
  176.  
  177. function stupcase(st: strng): strng;
  178.  
  179. var i: integer;
  180.  
  181. begin
  182.   for i := 1 to length(st) do
  183.     st[i] := upcase(st[i]);
  184.   stupcase := st
  185. end;  { stupcase }
  186.  
  187. procedure endskip;
  188.  
  189. begin                { underline skipped part of input }
  190.   while errpos < cc do
  191.   begin
  192.     write(psout,'-'); errpos := errpos + 1
  193.   end ;
  194.   skipflag := false
  195. end { endskip } ;
  196.  
  197. procedure nextch;   { read next character; process line end }
  198.  
  199. begin
  200.   if cc = ll
  201.   then begin
  202.     if eof(psin)
  203.     then begin
  204.       writeln(psout);
  205.       writeln(psout,' program incomplete');
  206.       errormsg;
  207.       close(psout); halt;     { abort }
  208.     end ;
  209.     if errpos <> 0
  210.     then begin
  211.       if skipflag then endskip;
  212.       writeln(psout);
  213.       errpos := 0
  214.     end ;
  215.     write(psout,lc:5, '  ');
  216.     ll := 0; cc := 0;
  217.     while not eoln(psin) do
  218.     begin
  219.       if ll > llng-2 then fatal(8);
  220.       read(psin,ch);
  221.       if ch <> chr(10) then begin
  222.         if ord(ch) < 32 then ch := ' ';
  223.         write(psout,ch);
  224.         ll := ll+1;
  225.         line[ll] := ch
  226.       end
  227.     end ;
  228.     ll := ll+1; line[ll] := ' ';
  229.     read(psin,ch); writeln(psout);
  230.   end ;
  231.   cc := cc+1; ch := line[cc];
  232. end { nextch } ;
  233.  
  234. procedure error(n: integer);
  235.  
  236. begin
  237.   if errpos = 0 then write(psout,' ****');
  238.   if cc > errpos
  239.   then begin
  240.     write(psout,' ': cc-errpos, '^', n:2);
  241.     errpos := cc+3; errs := errs + [n]
  242.   end
  243. end { error } ;
  244.  
  245. procedure insymbol;           { reads next symbol }
  246.  
  247. const dotdot = #31;
  248. label  1,2,3 ;
  249. var    i,j,k,e: integer;
  250.        sbuff: string[132];
  251.  
  252.   procedure readscale;
  253.  
  254.   var    s, sign: integer;
  255.   begin
  256.     nextch;
  257.     sign := 1; s := 0;
  258.     if ch = '+'
  259.     then nextch
  260.     else if ch = '-'
  261.          then begin
  262.            nextch; sign := -1
  263.          end ;
  264.     if not ((ch>='0') and (ch<='9'))
  265.     then error(40)
  266.     else repeat
  267.            s := 10*s + ord(ch)-ord('0');
  268.            nextch
  269.          until not ((ch>='0') and (ch<='9'));
  270.     e := s*sign + e
  271.   end { readscale } ;
  272.  
  273.   procedure adjustscale;
  274.  
  275.   var    s  : integer;
  276.          d,t: real;
  277.   begin
  278.   if k+e > emax
  279.   then error(21)
  280.   else if k+e < emin
  281.        then rnum := 0
  282.        else begin
  283.          s := abs(e); t := 1.0; d := 10.0;
  284.          repeat
  285.            while not odd(s) do
  286.            begin
  287.              s := s div 2; d := sqr(d)
  288.            end ;
  289.            s := s-1; t := d*t
  290.          until s = 0;
  291.  
  292.          if e >= 0
  293.          then rnum := rnum*t
  294.          else rnum := rnum/t
  295.        end
  296.   end { adjustscale } ;
  297.  
  298. procedure options;
  299.  
  300.   procedure switch(var b: boolean);
  301.  
  302.   begin
  303.     b:=ch='+';
  304.     if not b
  305.     then if not (ch='-')
  306.          then  begin
  307.            error(6);
  308.            while (ch<>'*') and (ch<>',') and (ch<>'}') do nextch;
  309.          end
  310.          else nextch
  311.     else nextch
  312.   end { switch } ;
  313.  
  314.   begin      {options}
  315.     repeat
  316.       nextch;
  317.       if (ch <> '*') and (ch <> '}')
  318.       then begin
  319.         if ((ch='t') or (ch='T'))
  320.         then begin
  321.           nextch; switch(prtables)
  322.         end else if ((ch='s') or (ch='S'))
  323.                  then begin
  324.                    nextch; switch(stackdump)
  325.                  end
  326.       end
  327.     until ch<>','
  328.   end  { options } ;
  329.  
  330. begin    { insymbol }
  331.  
  332. 1: while ch = ' ' do nextch;
  333.  
  334.   if ch in ['a'..'z','A'..'Z']
  335.   then begin { identifier or wordsymbol }
  336.       k := 0; id := '          ';
  337.       if ch in ['A'..'Z'] then ch := chr(ord(ch)+32);
  338.       repeat
  339.         if k < alng
  340.         then begin
  341.           k := k+1; id[k] := ch
  342.         end ;
  343.         nextch;
  344.         if ch in ['A'..'Z'] then ch := chr(ord(ch)+32)
  345.       until not ( (ch in ['a'..'z']) or (ch in ['0'..'9'])
  346.                   or (ch='_') );
  347.       i := 1; j:= nkw;    { binary search }
  348.       repeat
  349.         k := (i+j) div 2;
  350.         if id <= key[k] then j := k-1;
  351.         if id >= key[k] then i := k+1
  352.       until i > j;
  353.       if i-1 > j then sy := ksy[k] else sy := ident
  354.     end
  355.  
  356.   else if ch in ['+','-','*','/',')','=',',','[',']',';','&','|','~']
  357.   then begin
  358.       sy := sps[ch]; nextch
  359.     end
  360.  
  361.   else if ch in ['0'..'9']
  362.   then begin { number }
  363.       k := 0; inum := 0; sy := intcon;
  364.       repeat
  365.         inum := inum*10 + ord(ch) - ord('0');
  366.         k := k+1;
  367.         nextch
  368.       until not ((ch>='0') and (ch<='9'));
  369.  
  370.       if (k > kmax) or (inum > nmax)
  371.       then begin
  372.         error(21); inum := 0; k := 0
  373.       end ;
  374.       if ch = '.'
  375.       then begin
  376.         nextch;
  377.         if ch = '.'
  378.         then ch := dotdot
  379.         else begin
  380.           sy := realcon; rnum := inum; e := 0;
  381.           while (ch>='0') and (ch<='9') do
  382.           begin
  383.             e := e-1;
  384.             rnum := 10.0*rnum + (ord(ch)-ord('0'));
  385.             nextch
  386.           end ;
  387.           if e = 0 then error(40);
  388.           if ((ch = 'e') or (ch = 'E')) then readscale;
  389.           if e <> 0 then adjustscale
  390.         end
  391.       end else
  392.         if ((ch = 'e') or (ch = 'E'))
  393.         then begin
  394.           sy := realcon; rnum := inum; e := 0;
  395.           readscale;
  396.           if e <> 0 then adjustscale
  397.         end ;
  398.     end
  399.  
  400.   else case ch of
  401.  
  402. ':' :
  403.     begin
  404.       nextch;
  405.       if ch = '='
  406.       then begin
  407.         sy := becomes; nextch
  408.       end  else sy := colon
  409.     end;
  410.  
  411. '<' :
  412.     begin
  413.       nextch;
  414.       if ch = '='
  415.       then begin
  416.         sy := leq; nextch
  417.       end else
  418.         if ch = '>'
  419.         then begin
  420.           sy := neq; nextch
  421.         end else sy := lss
  422.     end;
  423.  
  424. '>' :
  425.     begin
  426.       nextch;
  427.       if ch = '='
  428.       then begin
  429.         sy := geq; nextch
  430.       end else sy := gtr
  431.     end;
  432.  
  433. '.' :
  434.     begin
  435.       nextch;
  436.       if ch = '.'
  437.       then begin
  438.         sy := twodots; nextch
  439.       end else sy := period
  440.     end;
  441.  
  442. dotdot:
  443.     begin
  444.       sy := twodots; nextch
  445.     end;
  446.  
  447. '''' :
  448.     begin
  449.       sbuff := '';
  450.  2:   nextch;
  451.       if ch = ''''
  452.       then  begin
  453.         nextch;
  454.         if ch <> '''' then goto 3
  455.       end ;
  456.       if length(sbuff) < 132
  457.       then sbuff := sbuff + ch
  458.       else error(38);
  459.       if cc = 1
  460.       then error(38)  { end of line }
  461.       else goto 2;
  462.  
  463.  3:   if length(sbuff) = 1
  464.       then begin
  465.         sy := charcon; inum := ord(sbuff[1])
  466.       end else begin
  467.         sy := stringcon;
  468.         sleng := length(sbuff);
  469.         if sleng=0
  470.         then spnt := ptr(nul,0)
  471.         else begin
  472.           getmem(spnt,((sleng+3) div 16 +1)*16);
  473.           k := seg(spnt^);
  474.           memw[k:0] := sleng;
  475.           memw[k:2] := 0;
  476.           move(sbuff[1],mem[k:4],sleng);
  477.         end;
  478.       end
  479.     end;
  480.  
  481. '(' :
  482.     begin
  483.       nextch;
  484.       if ch <> '*'
  485.       then sy := lparent
  486.       else begin { comment }
  487.         nextch;
  488.         if ch='$' then options;
  489.         repeat
  490.           while ch <>  '*' do nextch;
  491.           nextch
  492.         until ch = ')';
  493.         nextch; goto 1
  494.       end
  495.     end;
  496.  
  497. '{' :
  498.     begin { comment }
  499.       nextch;
  500.       if ch='$' then options;
  501.       while ch <> '}' do nextch;
  502.       nextch; goto 1
  503.     end;
  504.  
  505.   else nextch; error(24); goto 1
  506.  
  507.   end {case}
  508. end {insymbol } ;
  509.  
  510. procedure enter(x0: alfa;  x1: object;
  511.                 x2: types; x3: integer);
  512.  
  513. begin
  514.   t := t+1;         { enter standard identifier }
  515.   with tab[t] do
  516.   begin
  517.     name := x0; link := t-1; obj := x1;
  518.     typ := x2; ref := 0; normal := true;
  519.     lev := 0; adr := x3
  520.   end
  521. end { enter } ;
  522.  
  523. procedure enterarray(tp: types; l,h: integer);
  524.  
  525. begin
  526.   if l > h then error(27);
  527.   if (abs(l)>xmax) or (abs(h)>xmax)
  528.   then begin
  529.     error(27); l := 0; h := 0;
  530.   end ;
  531.   if a = amax
  532.   then fatal(4)
  533.   else begin
  534.     a := a+1;
  535.     with atab[a] do
  536.     begin
  537.       inxtyp := tp; low := l; high := h
  538.     end
  539.   end
  540. end {enterarray } ;
  541.  
  542. procedure enterblock;
  543.  
  544. begin
  545.   if b = bmax
  546.   then fatal(2)
  547.   else begin
  548.     b := b+1; btab[b].last := 0; btab[b].lastpar := 0
  549.   end
  550. end { enterblock } ;
  551.  
  552. procedure enterreal(x: real);
  553.  
  554. begin
  555.   if c2 = c2max-1
  556.   then fatal(3)
  557.   else begin
  558.     rconst[c2+1] := x; c1 := 1;
  559.     while rconst[c1] <> x do c1 := c1+1;
  560.     if c1 > c2 then c2 := c1
  561.   end
  562. end { enterreal } ;
  563.  
  564. procedure emit(fct: integer);
  565.  
  566. begin
  567.   if lc = cmax then fatal(6);
  568.   code[lc].f := fct; lc := lc+1
  569. end { emit } ;
  570.  
  571. procedure emit1(fct,b: integer);
  572.  
  573. begin
  574.   if lc = cmax then fatal(6);
  575.   with code[lc] do
  576.   begin
  577.     f := fct; y := b
  578.   end ;
  579.   lc := lc+1
  580. end { emit1 } ;
  581.  
  582. procedure emit2(fct,a,b: integer);
  583.  
  584. begin
  585.   if lc = cmax then fatal(6);
  586.   with code[lc] do
  587.   begin
  588.     f := fct; x := a; y := b
  589.   end ;
  590.   lc := lc+1
  591. end { emit2 } ;
  592.  
  593. procedure printtables;
  594.  
  595. var    i:integer;
  596.        o: order;
  597.  
  598. begin
  599.   writeln(psout); writeln(psout); writeln(psout);
  600.   writeln(psout,'   identifiers link  obj  typ  ref  nrm  lev  adr');
  601.   writeln(psout);
  602.   for i := btab[1].last to t do
  603.     with tab[i] do
  604.       writeln(psout,i,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
  605.               ord(normal):5, lev:5, adr:5);
  606.  
  607.   writeln(psout); writeln(psout); writeln(psout);
  608.   writeln(psout,'blocks    last lpar psze vsze');
  609.   writeln(psout);
  610.   for i := 1 to b do
  611.     with btab[i] do
  612.       writeln(psout,i:4, last:9, lastpar:5, psize:5, vsize:5);
  613.  
  614.   writeln(psout); writeln(psout); writeln(psout);
  615.   writeln(psout,'arrays    xtyp etyp eref  low high elsz size');
  616.   writeln(psout);
  617.  
  618.   for i := 1 to a do
  619.     with atab[i] do
  620.       writeln(psout,i:4, ord(inxtyp):9, ord(eltyp):5,
  621.               elref:5, low:5, high:5, elsize:5, size:5);
  622.  
  623.   writeln(psout); writeln(psout); writeln(psout);
  624.   writeln(psout,' code:'); writeln(psout);
  625.  
  626.   for i:=0 to lc-1 do
  627.   begin
  628.     write(psout); write(psout,i:5);
  629.     o := code[i]; write(psout,o.f:5);
  630.     if o.f < 100
  631.     then if o.f<4
  632.          then write(psout,o.x:2, o.y:5)
  633.          else write(psout,o.y:7)
  634.     else write(psout,'       ');
  635.     writeln(psout,',')
  636.   end;
  637.   writeln(psout);
  638.   writeln(psout,'Starting address is ',tab[btab[1].last].adr:5)
  639.  
  640. end { printtables };
  641.  
  642. procedure block(fsys: symset; isfun: boolean; level: integer); forward;
  643.  
  644. {$I BLOCK.PAS }
  645.  
  646. {$I INTERPRT.PAS }
  647.  
  648. procedure block;
  649.  
  650. begin
  651.   blockov(fsys,isfun,level)
  652. end;
  653.  
  654. procedure setup;
  655.  
  656. begin
  657.   key[ 1] := 'and       '; key[ 2] := 'array     ';
  658.   key[ 3] := 'begin     '; key[ 4] := 'case      ';
  659.   key[ 5] := 'const     '; key[ 6] := 'div       ';
  660.   key[ 7] := 'do        '; key[ 8] := 'downto    ';
  661.   key[ 9] := 'else      '; key[10] := 'end       ';
  662.   key[11] := 'file      '; key[12] := 'for       ';
  663.   key[13] := 'function  '; key[14] := 'goto      ';
  664.   key[15] := 'if        '; key[16] := 'in        ';
  665.   key[17] := 'label     '; key[18] := 'mod       ';
  666.   key[19] := 'nil       '; key[20] := 'not       ';
  667.   key[21] := 'of        '; key[22] := 'or        ';
  668.   key[23] := 'packed    '; key[24] := 'procedure ';
  669.   key[25] := 'program   '; key[26] := 'record    ';
  670.   key[27] := 'repeat    '; key[28] := 'set       ';
  671.   key[29] := 'then      '; key[30] := 'to        ';
  672.   key[31] := 'type      '; key[32] := 'until     ';
  673.   key[33] := 'var       '; key[34] := 'while     ';
  674.   key[35] := 'with      ';
  675.   ksy[ 1] := andsy;        ksy[ 2] := arraysy;
  676.   ksy[ 3] := beginsy;      ksy[ 4] := casesy;
  677.   ksy[ 5] := constsy;      ksy[ 6] := idiv;
  678.   ksy[ 7] := dosy;         ksy[ 8] := downtosy;
  679.   ksy[ 9] := elsesy;       ksy[10] := endsy;
  680.   ksy[11] := filesy;       ksy[12] := forsy;
  681.   ksy[13] := funcsy;       ksy[14] := gotosy;
  682.   ksy[15] := ifsy;         ksy[16] := insy;
  683.   ksy[17] := labelsy;      ksy[18] := imod;
  684.   ksy[19] := nilsy;        ksy[20] := notsy;
  685.   ksy[21] := ofsy;         ksy[22] := orsy;
  686.   ksy[23] := packedsy;     ksy[24] := procsy;
  687.   ksy[25] := programsy;    ksy[26] := recordsy;
  688.   ksy[27] := repeatsy;     ksy[28] := setsy;
  689.   ksy[29] := thensy;       ksy[30] := tosy;
  690.   ksy[31] := typesy;       ksy[32] := untilsy;
  691.   ksy[33] := varsy;        ksy[34] := whilesy;
  692.   ksy[35] := withsy;
  693.  
  694.   sps['+'] := plus;        sps['-'] := minus;
  695.   sps['*'] := times;       sps['/'] := rdiv;
  696.   sps[')'] := rparent;
  697.   sps['='] := eql;         sps[','] := comma;
  698.   sps['['] := lbrack;      sps[']'] := rbrack;
  699.   sps['~'] := notsy;       sps['&'] := andsy;
  700.   sps[';'] := semicolon;   sps['|'] := orsy;
  701. end { setup } ;
  702.  
  703. procedure enterids;
  704.  
  705. begin
  706.   enter('          ', vvariable, notyp, 0);  { sentinel }
  707.   enter('false     ', konstant, bools, 0);
  708.   enter('true      ', konstant, bools, 1);
  709.   enter('real      ', type1, reals, 1);
  710.   enter('char      ', type1, chars, 1);
  711.   enter('boolean   ', type1, bools, 1);
  712.   enter('integer   ', type1, ints , 1);
  713.   enter('string    ', type1, strngs,1);
  714.   enter('abs       ', funktion, reals,0);
  715.   enter('sqr       ', funktion, reals,2);
  716.   enter('odd       ', funktion, bools,4);
  717.   enter('chr       ', funktion, chars,5);
  718.   enter('ord       ', funktion, ints, 6);
  719.   enter('succ      ', funktion, chars,7);
  720.   enter('pred      ', funktion, chars,8);
  721.   enter('round     ', funktion, ints, 9);
  722.   enter('trunc     ', funktion, ints, 10);
  723.   enter('sin       ', funktion, reals, 11);
  724.   enter('cos       ', funktion, reals, 12);
  725.   enter('exp       ', funktion, reals, 13);
  726.   enter('ln        ', funktion, reals, 14);
  727.   enter('sqrt      ', funktion, reals, 15);
  728.   enter('arctan    ', funktion, reals, 16);
  729.   enter('eof       ', funktion, bools, 17);
  730.   enter('eoln      ', funktion, bools, 18);
  731.   enter('maxavail  ', funktion, ints, 19);
  732.   enter('length    ', funktion, ints, 20);
  733.   enter('copy      ', funktion, strngs, 23);
  734.   enter('pos       ', funktion, ints, 26);
  735.   enter('str       ', funktion, strngs, 33);
  736.   enter('val       ', funktion, ints, 35);
  737.   enter('rval      ', funktion, reals, 37);
  738.   enter('read      ', prozedure, notyp, 1);
  739.   enter('readln    ', prozedure, notyp, 2);
  740.   enter('write     ', prozedure, notyp, 3);
  741.   enter('writeln   ', prozedure, notyp, 4);
  742.   enter('          ', prozedure, notyp, 0);
  743. end;  { enterids }
  744.  
  745. procedure startup;
  746.  
  747. var
  748.   exists: boolean;
  749.  
  750. begin
  751.   writeln('                    Facilis   version ', version:4:2);
  752.   writeln;
  753.   repeat
  754.     write('  Source input file [.PAS] ? '); readln(inf);
  755.     inf := stupcase(inf);
  756.     if pos('.',inf) = 0
  757.       then inf := inf + '.PAS';
  758.     assign(psin,inf);
  759.     {$I-} reset(psin) {$I+} ;
  760.     exists := (ioresult = 0);
  761.     if not exists
  762.       then writeln('File ', inf, ' not found');
  763.   until exists;
  764.  
  765.   tempstr := copy(inf,1,pos('.',inf)) + 'LST';
  766.   repeat
  767.     repeat
  768.       write('Source listing file [',tempstr,'] ? ');
  769.       readln(outf); outf := stupcase(outf);
  770.     until inf <> outf;
  771.     if outf = ''
  772.       then outf := tempstr;
  773.     assign(psout,outf);
  774.     {$I-} rewrite(psout) {$I+} ;
  775.     exists := (ioresult = 0);
  776.     if not exists
  777.       then writeln('can''t open file ',outf);
  778.   until exists;
  779. end;  { startup }
  780.  
  781. begin { main }
  782.  
  783.   setup;
  784.  
  785.   constbegsys := [plus,minus,intcon,realcon,charcon,stringcon,ident];
  786.   typebegsys  := [ident,arraysy,recordsy];
  787.   blockbegsys := [constsy,typesy,varsy,procsy,funcsy,beginsy];
  788.   facbegsys   := [intcon,realcon,charcon,stringcon,ident,lparent,notsy];
  789.   statbegsys  := [beginsy,ifsy,whilesy,repeatsy,forsy,casesy];
  790.   stantyps    := [notyp,ints,reals,bools,chars,strngs];
  791.  
  792.       lc := 0;             ll := 0;
  793.       cc := 0;             ch := ' ';
  794.   errpos := 0;           errs := [];
  795.  
  796.   writeln;
  797.   startup;
  798.  
  799.   assign(prd,'trm:');
  800.   reset(prd);
  801.   assign(prr,'con:');
  802.   rewrite(prr);
  803.  
  804.          t := -1;                 a := 0;
  805.          b :=  1;
  806.         c2 :=  0;        display[0] := 1;
  807.   skipflag := false;        prtables:= false;
  808.   stackdump:= false;
  809.  
  810.   getmem(spnt,16);
  811.   if ofs(spnt^) <> 0 then begin
  812.     freemem(spnt,16); getmem(spnt,8);
  813.     getmem(spnt,16); end;
  814.   nul := seg(spnt^);
  815.   memw[nul:0] := 0; memw[nul:2] := 0;
  816.  
  817.   insymbol;
  818.   if sy <> programsy
  819.   then error(3)
  820.   else begin
  821.     insymbol;
  822.     if sy <> ident
  823.     then error(2)
  824.     else begin
  825.       progname := id;
  826.       insymbol;
  827.       if sy = lparent
  828.       then begin
  829.         repeat
  830.           insymbol;
  831.           if sy<> ident
  832.           then error(2)
  833.           else insymbol
  834.         until sy <> comma;
  835.         if sy = rparent then insymbol else error(4);
  836.       end
  837.     end
  838.   end ;
  839.  
  840.   enterids;
  841.   with btab[1] do
  842.     begin
  843.       last := t; lastpar := 1; psize := 0; vsize := 0;
  844.     end ;
  845.  
  846.   block(blockbegsys+statbegsys, false, 1);
  847.   if sy <> period then error(22);
  848.   emit(131);  { halt }
  849.  
  850.   if prtables then printtables;
  851.   if errs=[]
  852.   then interpret
  853.   else begin
  854.     writeln(psout);
  855.     writeln(psout,'compiled with errors');
  856.     writeln(psout);
  857.     errormsg;
  858.   end;
  859.  
  860.   writeln(psout);
  861.  
  862.   close(psout);
  863.   close(prr)
  864.  
  865. end.